# speaker informativity
# ---------------------
speaker.inf = function(d, alpha, cost = 0) {
exp(alpha*(log(d) - cost))
}
# speaker likelihood
# ------------------
speaker.lhd = function(rating, degree, m, alpha) {
numerator = speaker.inf(m[rating, degree], alpha)
normalize = sum(sapply(m[rating, ], function(i) {speaker.inf(i, alpha)}))
return(numerator / normalize)
}
# non-normalized posterior
# -----------------------
nn.post = function(rating, degree, m, alpha, useprior) {
prior = priors[rating, "prior.p"]
return(speaker.lhd(rating, degree, m, alpha) * prior)
}
# normalized posterior
# --------------------
norm.post = function(rating, degree, m, alpha, useprior) {
nn = nn.post(rating, degree, m, alpha, useprior)
normalize = sum(unlist(sapply(seq(1, 5), function(i){nn.post(i, degree, m, alpha, useprior)})))
return(nn / normalize)
}
# run.partial()
# ------------
# Run RSA with model1 (entailment) and model2 (entailment + generic)
run.partial = function(d, alpha=1, useprior=F, usenone=F, normalize=F) {
if (normalize) {
mat = d %>%
select(stars, degree, speaker.p) %>%
spread(degree, speaker.p) %>%
mutate(hi = hi / sum(hi),
low = low / sum(low)) %>%
select(hi, low)
} else {
mat = d %>%
select(stars, degree, speaker.p) %>%
spread(degree, speaker.p) %>%
select(hi, low)
}
if (usenone) {
mat$none = c(1, 0, 0, 0, 0)
}
d$pred = round(as.numeric(mapply(norm.post, d$stars, d$degree,
MoreArgs = list(m = mat,
alpha = alpha,
useprior = useprior))),
digits=4)
return(d)
}
# run.full()
# ------------
# Run RSA with model3 (full) with alternatives
run.full = function(d, alpha=1, useprior=F, usenone=F, addMid=F, normalize=F) {
# alpha = scales.entropy[scales.entropy$scale==d$scale[1], ]$Entropy
if (addMid) {
if (normalize) {
mat = d %>%
select(stars, degree, speaker.p) %>%
spread(degree, speaker.p) %>%
mutate(hi1 = hi1 / sum(hi1),
hi2 = hi2 / sum(hi2),
mid = mid / sum(mid),
low1 = low1 / sum(low1),
low2 = low2 / sum(low2)) %>%
select(hi1, hi2, mid, low1, low2)
} else {
mat = d %>%
select(stars, degree, speaker.p) %>%
spread(degree, speaker.p) %>%
select(hi1, hi2, mid, low1, low2)
}
} else {
if (normalize) {
mat = d %>%
select(stars, degree, speaker.p) %>%
spread(degree, speaker.p) %>%
mutate(hi1 = hi1 / sum(hi1),
hi2 = hi2 / sum(hi2),
low1 = low1 / sum(low1),
low2 = low2 / sum(low2)) %>%
select(hi1, hi2, low1, low2)
} else {
mat = d %>%
select(stars, degree, speaker.p) %>%
spread(degree, speaker.p) %>%
select(hi1, hi2, low1, low2)
}
}
if (usenone) {
mat$none = c(1, 0, 0, 0, 0)
}
d$pred = round(as.numeric(mapply(norm.post, d$stars, d$degree,
MoreArgs = list(m = mat,
alpha = alpha,
useprior = useprior))),
digits=4)
return(d)
}
# tune.alhpa()
# ------------
# d --> data
# alphas --> range of alphas to test
# type --> full or partial model
# useprior --> use uniform prior
# usenone --> use gener None
tune.alpha = function(d, alphas = seq(from=1, to=10),
type="partial", useprior = T,
usenone=F, compare.data=NULL, addMid = F, normalize=F) {
# Tune best alphas
fit = sapply(alphas, FUN=function(n) {
if (type == "partial") {
md = d %>%
do(run.partial(., alpha=n, useprior=useprior, usenone=usenone, normalize=normalize))
} else {
md = d %>%
do(run.full(., alpha=n, useprior=useprior, usenone=usenone, addMid=addMid, normalize=normalize))
}
# Toggle fit to e6 data
if (!is.null(compare.data)) {
# If we're using e11 data with multiple scalars
if ("hi1" %in% md$degree) {
matched.items = which((md[, "scale"] != "some_all" &
(md[, "degree"] == "hi2" | md[, "degree"] == "hi1")) |
(md[, "scale"] == "some_all" &
(md[, "degree"] == "hi1" | md[, "degree"] == "low1")))
md = md[matched.items, ]
md$degree = ifelse(md$degree == "hi1", "hi", "low")
stopifnot("listener.p" %in% colnames(compare.data))
}
md$listener.p = compare.data$listener.p
}
# MSE
return(mean((md$pred - md$listener.p)^2))
})
# get lowest MSE
best.alpha = which(fit == min(fit))
return(best.alpha)
}
# Uniform priors
unif.priors = data.frame(stars = seq(1, 5), prior.p = rep(0.2, 5))
emp.priors = read.csv("~/Desktop/Projects/scalar_implicature/models/model_data/emp_priors.csv")
priors = unif.priors
scales.entropy = read.csv("~/Desktop/Projects/scalar_implicature/models/model_data/scales_entropy.csv")
speaker = read.csv("~/Desktop/Projects/scalar_implicature/models/model_data/L0_e8.csv")
listener = read.csv("~/Desktop/Projects/scalar_implicature/models/model_data/L1_e6.csv")
# Combine speaker / listener
data.partial = left_join(speaker, listener) %>%
left_join(priors) %>%
rowwise %>%
select(scale, degree, stars, speaker.p, listener.p, prior.p) %>%
mutate(listener.p = ifelse(is.na(listener.p), 0, listener.p)) %>%
group_by(scale)
speaker = read.csv("~/Desktop/Projects/scalar_implicature/models/model_data/L0_e10.csv")
listener = read.csv("~/Desktop/Projects/scalar_implicature/models/model_data/L1_e11.csv")
data.full = left_join(speaker, listener) %>%
left_join(priors) %>%
rowwise %>%
select(scale, degree, stars, speaker.p, listener.p, prior.p) %>%
mutate(listener.p = ifelse(is.na(listener.p), 0, listener.p)) %>%
group_by(scale)
# made up alts in 'L0_e10a.csv'
# fitted alts in 'L0_e10fittedAlts.csv'
speaker = read.csv("~/Desktop/Projects/scalar_implicature/models/model_data/L0_e10fittedAlts.csv")
data.full.extras = left_join(speaker, listener) %>%
left_join(priors) %>%
rowwise %>%
select(scale, degree, stars, speaker.p, listener.p, prior.p) %>%
mutate(listener.p = ifelse(is.na(listener.p), 0, listener.p)) %>%
group_by(scale)
## Joining by: c("scale", "degree", "stars")
## Warning in left_join_impl(x, y, by$x, by$y): joining factors with different
## levels, coercing to character vector
## Joining by: "stars"
## Warning: Grouping rowwise data frame strips rowwise nature
matched.items = which((data.full[, "scale"] != "some_all" &
(data.full[, "degree"] == "hi2" | data.full[, "degree"] == "hi1")) |
(data.full[, "scale"] == "some_all" &
(data.full[, "degree"] == "hi1" | data.full[, "degree"] == "low1")))
matched.items.extras = which((data.full.extras[, "scale"] != "some_all" &
(data.full.extras[, "degree"] == "hi2" | data.full.extras[, "degree"] == "hi1")) |
(data.full.extras[, "scale"] == "some_all" &
(data.full.extras[, "degree"] == "hi1" | data.full.extras[, "degree"] == "low1")))
# Save performance output
performance.output = data.frame(model=rep(NA, 16),
cor.e6=rep(NA, 16),
cor.e11=rep(NA, 16),
normalized=rep(NA, 16))
alphas = rep(NA, 16)
data.full.transfer = data.full[matched.items, ]
data.full.transfer$degree =
ifelse(data.full.transfer$degree == "hi1", "hi", "low")
# Model 1 - Entailment only models
# --------------------------------
# 1.a)
# Entailment only
# Normalized = T
# alpha tuning = F
alphas[1] = 1
m1.a = data.partial %>%
do(run.partial(., alpha = alphas[1], useprior=T, usenone=F, normalize=T))
# Store output and add e11
m1.a = cbind(m1.a, data.full.transfer$listener.p)
colnames(m1.a)[8] = "e11.listener.p"
performance.output[1, ] = c("m1.a", round(cor(m1.a$listener.p, m1.a$pred), 5),
round(cor(m1.a$e11.listener.p, m1.a$pred), 5), T)
# Store plot
m1.a.plot = qplot(stars, listener.p, col=degree,
data=m1.a,
main=paste("m1.a\nalpha: ", alphas[1],
"\nNormalized = ", T,
"\nCorr = ", performance.output[1, 2]),
ylab="Posterior p(rating | word)") +
ylim(0, 1) +
facet_wrap(~scale) +
geom_line(aes(y = pred), lty = 4)
# 1.b)
# Entailment only
# Normalized = F
# alpha tune = F
alphas[2] = 1
m1.b = data.partial %>%
do(run.partial(., alpha = alphas[1], useprior=T, usenone=F, normalize=F))
# Store output
m1.b = cbind(m1.b, data.full.transfer$listener.p)
colnames(m1.b)[8] = "e11.listener.p"
performance.output[2, ] = c("m1.b", round(cor(m1.b$listener.p, m1.b$pred), 5),
round(cor(m1.b$e11.listener.p, m1.b$pred), 5), F)
# Store plot
m1.b.plot = qplot(stars, listener.p, col=degree,
data=m1.b,
main=paste("m1.b\nalpha: ", alphas[2],
"\nNormalized = ", F,
"\nCorr = ", performance.output[2, 2]),
ylab="Posterior p(rating | word)") +
ylim(0, 1) +
facet_wrap(~scale) +
geom_line(aes(y = pred), lty = 4)
# 1.c)
# Entailment only
# Normalized = T
# alpha tune = T
alphas[3] = tune.alpha(data.partial, normalize=T, compare.data=data.full.transfer)
m1.c = data.partial %>%
do(run.partial(., alpha = alphas[3], useprior=T, usenone=F, normalize=T))
# Store output
m1.c = cbind(m1.c, data.full.transfer$listener.p)
colnames(m1.c)[8] = "e11.listener.p"
performance.output[3, ] = c("m1.c", round(cor(m1.c$listener.p, m1.c$pred), 5),
round(cor(m1.c$e11.listener.p, m1.c$pred), 5), T)
# Store plot
m1.c.plot = qplot(stars, listener.p, col=degree,
data=m1.c,
main=paste("m1.c\nalpha: ", alphas[3],
"\nNormalized = ", T,
"\nCorr = ", performance.output[3, 2]),
ylab="Posterior p(rating | word)") +
ylim(0, 1) +
facet_wrap(~scale) +
geom_line(aes(y = pred), lty = 4)
# 1.d)
# Entailment only
# Normalized = F
# alpha tune = T
alphas[4] = tune.alpha(data.partial, normalize=F)
m1.d = data.partial %>%
do(run.partial(., alpha = alphas[4], useprior=T, usenone=F, normalize=F))
# Store output
m1.d = cbind(m1.d, data.full.transfer$listener.p)
colnames(m1.d)[8] = "e11.listener.p"
performance.output[4, ] = c("m1.d", round(cor(m1.d$listener.p, m1.d$pred), 5),
round(cor(m1.d$e11.listener.p, m1.d$pred), 5), normalized=F)
# Store plot
m1.d.plot = qplot(stars, listener.p, col=degree,
data=m1.d,
main=paste("m1.d\nalpha: ", alphas[4],
"\nNormalized = ", F,
"\nCorr = ", performance.output[4, 2]),
ylab="Posterior p(rating | word)") +
ylim(0, 1) +
facet_wrap(~scale) +
geom_line(aes(y = pred), lty = 4)
# Model 2 - Entailment + generic none
# --------------------------------
# 2.a)
# Entailment + generic None
# Normalized = T
# alpha tuning = F
alphas[5] = 1
m2.a = data.partial %>%
do(run.partial(., alpha = alphas[5], useprior=T, usenone=T, normalize=T))
# Store output
m2.a = cbind(m2.a, data.full.transfer$listener.p)
colnames(m2.a)[8] = "e11.listener.p"
performance.output[5, ] = c("m2.a", round(cor(m2.a$listener.p, m2.a$pred), 5),
round(cor(m2.a$e11.listener.p, m2.a$pred), 5), T)
# Store plot
m2.a.plot = qplot(stars, listener.p, col=degree,
data=m2.a,
main=paste("m2.a\nalpha: ", alphas[5],
"\nNormalized = ", T,
"\nCorr = ", performance.output[5, 2]),
ylab="Posterior p(rating | word)") +
ylim(0, 1) +
facet_wrap(~scale) +
geom_line(aes(y = pred), lty = 4)
# 2.b)
# Entailment + generic None
# Normalized = F
# alpha tune = F
alphas[6] = 1
m2.b = data.partial %>%
do(run.partial(., alpha = alphas[6], useprior=T, usenone=T, normalize=F))
# Store output
m2.b = cbind(m2.b, data.full.transfer$listener.p)
colnames(m2.b)[8] = "e11.listener.p"
performance.output[6, ] = c("m2.b", round(cor(m2.b$listener.p, m2.b$pred), 5),
round(cor(m2.b$e11.listener.p, m2.b$pred), 5), F)
# Store plot
m2.b.plot = qplot(stars, listener.p, col=degree,
data=m2.b,
main=paste("m2.b\nalpha: ", alphas[6],
"\nNormalized = ", F,
"\nCorr = ", performance.output[6, 2]),
ylab="Posterior p(rating | word)") +
ylim(0, 1) +
facet_wrap(~scale) +
geom_line(aes(y = pred), lty = 4)
# 2.c)
# Entailment + generic None
# Normalized = T
# alpha tune = T
# compare.data = Toggle this with data.full.transfer for e11 or NULL for e6
alphas[7] = tune.alpha(data.partial, normalize=T, compare.data=NULL)
m2.c = data.partial %>%
do(run.partial(., alpha = alphas[7], useprior=T, usenone=T, normalize=T))
# Store output
m2.c = cbind(m2.c, data.full.transfer$listener.p)
colnames(m2.c)[8] = "e11.listener.p"
performance.output[7, ] = c("m2.c", round(cor(m2.c$listener.p, m2.c$pred), 5),
round(cor(m2.c$e11.listener.p, m2.c$pred), 5), T)
# Store plot
m2.c.plot = qplot(stars, listener.p, col=degree,
data=m2.c,
main=paste("m2.c\nalpha: ", alphas[7],
"\nNormalized = ", T,
"\nCorr = ", performance.output[7, 2]),
ylab="Posterior p(rating | word)") +
ylim(0, 1) +
facet_wrap(~scale) +
geom_line(aes(y = pred), lty = 4)
# 2.d)
# Entailment + generic None
# Normalized = F
# alpha tune = T
# compare.data = Toggle this with data.full.transfer for e11 or NULL for e6
alphas[8] = tune.alpha(data.partial, normalize=F)
m2.d = data.partial %>%
do(run.partial(., alpha = alphas[8], useprior=T, usenone=T, normalize=F))
# Store output
m2.d = cbind(m2.d, data.full.transfer$listener.p)
colnames(m2.d)[8] = "e11.listener.p"
performance.output[8, ] = c("m2.d", round(cor(m2.d$listener.p, m2.d$pred), 5),
round(cor(m2.d$e11.listener.p, m2.d$pred), 5), F)
# Store plot
m2.d.plot = qplot(stars, listener.p, col=degree,
data=m2.d,
main=paste("m2.d\nalpha: ", alphas[8],
"\nNormalized = ", F,
"\nCorr = ", performance.output[8, 2]),
ylab="Posterior p(rating | word)") +
ylim(0, 1) +
facet_wrap(~scale) +
geom_line(aes(y = pred), lty = 4)
# Model 3 - Empirical alternatives
# --------------------------------
# 3.a)
# Emp alts
# Normalized = T
# alpha tuning = F
alphas[9] = 1
m3.a = data.full %>%
do(run.full(., alpha = alphas[9], addMid=F, normalize=T))
# Match with e6 w/ checks
m3.a.matched = m3.a[matched.items, ]
m3.a.matched$degree = ifelse(m3.a.matched$degree == "hi1", "hi", "low")
m3.a.matched = cbind(m3.a.matched, data.partial$listener.p)
all(m3.a.matched$scale == data.partial$scale & m3.a.matched$degree == data.partial$degree)
## [1] TRUE
colnames(m3.a.matched)[length(colnames(m3.a.matched))] = "e6.listener.p"
# Store output
performance.output[9, ] = c("m3.a", round(cor(m3.a.matched$e6.listener.p, m3.a.matched$pred), 5),
round(cor(m3.a.matched$listener.p, m3.a.matched$pred), 5), T)
# Store plot
m3.a.plot = qplot(stars, e6.listener.p, col=degree,
data=m3.a.matched,
main=paste("m3.a\nalpha: ", alphas[9],
"\nNormalized = ", T,
"\nCorr = ", performance.output[9, 2]),
ylab="Posterior p(rating | word)") +
ylim(0, 1) +
facet_wrap(~scale) +
geom_line(aes(y = pred), lty = 4)
# 3.b)
# Emp alts
# Entailment + generic None
# Normalized = F
# alpha tune = F
alphas[10] = 1
m3.b = data.full %>%
do(run.full(., alpha = alphas[10], addMid=F, normalize=F))
# Match with e6 w/ checks
m3.b.matched = m3.b[matched.items, ]
m3.b.matched$degree = ifelse(m3.b.matched$degree == "hi1", "hi", "low")
m3.b.matched = cbind(m3.b.matched, data.partial$listener.p)
all(m3.b.matched$scale == data.partial$scale & m3.b.matched$degree == data.partial$degree)
## [1] TRUE
colnames(m3.b.matched)[length(colnames(m3.b.matched))] = "e6.listener.p"
# Store output
performance.output[10, ] = c("m3.b", round(cor(m3.b.matched$e6.listener.p, m3.b.matched$pred), 5),
round(cor(m3.b.matched$listener.p, m3.b.matched$pred), 5), F)
# Store plot
m3.b.plot = qplot(stars, e6.listener.p, col=degree,
data=m3.b.matched,
main=paste("m3.b\nalpha: ", alphas[10],
"\nNormalized = ", F,
"\nCorr = ", performance.output[10, 2]),
ylab="Posterior p(rating | word)") +
ylim(0, 1) +
facet_wrap(~scale) +
geom_line(aes(y = pred), lty = 4)
# 3.c)
# Emp alts
# Normalized = T
# alpha tune = T
# compare.data = Toggle this with data.partial for e6 or NULL for e11
alphas[11] = tune.alpha(data.full, type = "full", compare.data=data.partial, addMid=F, normalize=T)
m3.c = data.full %>%
do(run.full(., alpha = alphas[11], addMid=F, normalize=T))
# Match with e6 w/ checks
m3.c.matched = m3.c[matched.items, ]
m3.c.matched$degree = ifelse(m3.c.matched$degree == "hi1", "hi", "low")
m3.c.matched = cbind(m3.c.matched, data.partial$listener.p)
all(m3.c.matched$scale == data.partial$scale & m3.c.matched$degree == data.partial$degree)
## [1] TRUE
colnames(m3.c.matched)[length(colnames(m3.c.matched))] = "e6.listener.p"
# Store output
performance.output[11, ] = c("m3.c", round(cor(m3.c.matched$e6.listener.p, m3.c.matched$pred), 5),
round(cor(m3.c.matched$listener.p, m3.c.matched$pred), 5), T)
# Store plot 2 - both e6 and e11 data
m3.c.jointD = m3.c.matched %>%
gather(study, listener.pred, listener.p, e6.listener.p)
m3.c.jointD$study = ifelse(m3.c.jointD$study == "e6.listener.p", "e6", "e11")
m3.c.jointPlot = qplot(stars, listener.pred, col=degree, shape=study,
data=m3.c.jointD,
main=paste("m3.c\nalpha: ", alphas[11],
"\nNormalized = ", T,
ylab="Posterior p(rating | word)")) +
ylim(0, 1) +
facet_wrap(~scale) +
geom_line(aes(y = pred), lty = 4)
# 3.d)
# Emp alts
# Normalized = F
# alpha tune = T
# compare.data = Toggle this with data.partial or NULL
alphas[12] = tune.alpha(data.full, type = "full", compare.data=data.partial, addMid=F, normalize=F)
m3.d = data.full %>%
do(run.full(., alpha = alphas[12], addMid=F, normalize=F))
# Match with e6 w/ checks
m3.d.matched = m3.d[matched.items, ]
m3.d.matched$degree = ifelse(m3.d.matched$degree == "hi1", "hi", "low")
m3.d.matched = cbind(m3.d.matched, data.partial$listener.p)
all(m3.d.matched$scale == data.partial$scale & m3.d.matched$degree == data.partial$degree)
## [1] TRUE
colnames(m3.d.matched)[length(colnames(m3.d.matched))] = "e6.listener.p"
# Store output
performance.output[12, ] = c("m3.d", round(cor(m3.d.matched$e6.listener.p, m3.d.matched$pred), 5),
round(cor(m3.d.matched$listener.p, m3.d.matched$pred), 5), F)
# Store plot 2 - both e6 and e11 data
m3.d.jointD = m3.d.matched %>%
gather(study, listener.pred, listener.p, e6.listener.p)
m3.d.jointD$study = ifelse(m3.d.jointD$study == "e6.listener.p", "e6", "e11")
m3.d.jointPlot = qplot(stars, listener.pred, col=degree, shape=study,
data=m3.d.jointD,
main=paste("m3.d\nalpha: ", alphas[12],
"\nNormalized = ", T,
ylab="Posterior p(rating | word)")) +
ylim(0, 1) +
facet_wrap(~scale) +
geom_line(aes(y = pred), lty = 4)
# Model 4 - Empirical alternatives + extras
# -----------------------------------------
# 4.a)
# Emp alts + extras
# Normalized = T
# alpha tuning = F
alphas[13] = 1
m4.a = data.full.extras %>%
do(run.full(., alpha = alphas[13], addMid=T, normalize=T))
# Match with e6 w/ checks
m4.a.matched = m4.a[matched.items.extras, ]
m4.a.matched$degree = ifelse(m4.a.matched$degree == "hi1", "hi", "low")
m4.a.matched = cbind(m4.a.matched, data.partial$listener.p)
all(m4.a.matched$scale == data.partial$scale & m4.a.matched$degree == data.partial$degree)
## [1] TRUE
colnames(m4.a.matched)[length(colnames(m4.a.matched))] = "e6.listener.p"
# Store output
performance.output[13, ] = c("m4.a", round(cor(m4.a.matched$e6.listener.p, m4.a.matched$pred), 5),
round(cor(m4.a.matched$listener.p, m4.a.matched$pred), 5), T)
# Store plot
m4.a.plot = qplot(stars, e6.listener.p, col=degree,
data=m4.a.matched,
main=paste("m4.a\nalpha: ", alphas[13],
"\nNormalized = ", T,
"\nCorr = ", performance.output[13, 2]),
ylab="Posterior p(rating | word)") +
ylim(0, 1) +
facet_wrap(~scale) +
geom_line(aes(y = pred), lty = 4)
# 4.b)
# Emp alts + extras
# Normalized = F
# alpha tune = F
alphas[14] = 1
m4.b = data.full.extras %>%
do(run.full(., alpha = alphas[14], addMid=T, normalize=F))
# Match with e6 w/ checks
m4.b.matched = m4.b[matched.items.extras, ]
m4.b.matched$degree = ifelse(m4.b.matched$degree == "hi1", "hi", "low")
m4.b.matched = cbind(m4.b.matched, data.partial$listener.p)
all(m4.b.matched$scale == data.partial$scale & m4.b.matched$degree == data.partial$degree)
## [1] TRUE
colnames(m4.b.matched)[length(colnames(m4.b.matched))] = "e6.listener.p"
# Store output
performance.output[14, ] = c("m4.b", round(cor(m4.b.matched$e6.listener.p, m4.b.matched$pred), 5),
round(cor(m4.b.matched$listener.p, m4.b.matched$pred), 5), F)
# Store plot
m4.b.plot = qplot(stars, e6.listener.p, col=degree,
data=m4.b.matched,
main=paste("m4.b\nalpha: ", alphas[14],
"\nNormalized = ", F,
"\nCorr = ", performance.output[14, 2]),
ylab="Posterior p(rating | word)") +
ylim(0, 1) +
facet_wrap(~scale) +
geom_line(aes(y = pred), lty = 4)
# 4.c)
# Emp alts + extras
# Normalized = T
# alpha tune = T
# compare.data = Toggle this with data.partial or NULL
alphas[15] = tune.alpha(data.full.extras, type = "full", compare.data=data.partial, addMid=T, normalize=T)
m4.c = data.full.extras %>%
do(run.full(., alpha = alphas[15], addMid=T, normalize=T))
# Match with e6 w/ checks
m4.c.matched = m4.c[matched.items.extras, ]
m4.c.matched$degree = ifelse(m4.c.matched$degree == "hi1", "hi", "low")
m4.c.matched = cbind(m4.c.matched, data.partial$listener.p)
all(m4.c.matched$scale == data.partial$scale & m4.c.matched$degree == data.partial$degree)
## [1] TRUE
colnames(m4.c.matched)[length(colnames(m4.c.matched))] = "e6.listener.p"
# Store output (e11 and e6)
performance.output[15, ] = c("m4.c", round(cor(m4.c.matched$e6.listener.p, m4.c.matched$pred), 5),
round(cor(m4.c.matched$listener.p, m4.c.matched$pred), 5), T)
# Store plot 2 - both e6 and e11 data
m4.c.jointD = m4.c.matched %>%
gather(study, listener.pred, listener.p, e6.listener.p)
m4.c.jointD$study = ifelse(m4.c.jointD$study == "e6.listener.p", "e6", "e11")
m4.c.jointPlot = qplot(stars, listener.pred, col=degree, shape=study,
data=m4.c.jointD,
main=paste("m4.c\nalpha: ", alphas[15],
"\nNormalized = ", T,
ylab="Posterior p(rating | word)")) +
ylim(0, 1) +
facet_wrap(~scale) +
geom_line(aes(y = pred), lty = 4)
# 4.d)
# Emp alts + extras
# Normalized = F
# alpha tune = T
# compare.data = Toggle this with data.partial or NULL
alphas[16] = tune.alpha(data.full.extras, type = "full", compare.data=data.partial, addMid=T, normalize=F)
m4.d = data.full.extras %>%
do(run.full(., alpha = alphas[16], addMid=T, normalize=F))
# Match with e6 w/ checks
m4.d.matched = m4.d[matched.items.extras, ]
m4.d.matched$degree = ifelse(m4.d.matched$degree == "hi1", "hi", "low")
m4.d.matched = cbind(m4.d.matched, data.partial$listener.p)
all(m4.d.matched$scale == data.partial$scale & m4.d.matched$degree == data.partial$degree)
## [1] TRUE
colnames(m4.d.matched)[length(colnames(m4.d.matched))] = "e6.listener.p"
# Store output
performance.output[16, ] = c("m4.d", round(cor(m4.d.matched$e6.listener.p, m4.d.matched$pred), 5),
round(cor(m4.d.matched$listener.p, m4.d.matched$pred), 5), F)
# Store plot 2 - both e6 and e11 data
m4.d.jointD = m4.d.matched %>%
gather(study, listener.pred, listener.p, e6.listener.p)
m4.d.jointD$study = ifelse(m4.d.jointD$study == "e6.listener.p", "e6", "e11")
m4.d.jointPlot = qplot(stars, listener.pred, col=degree, shape=study,
data=m4.d.jointD,
main=paste("m4.d\nalpha: ", alphas[16],
"\nNormalized = ", T,
ylab="Posterior p(rating | word)")) +
ylim(0, 1) +
facet_wrap(~scale) +
geom_line(aes(y = pred), lty = 4)
m1: Entailment only models (i.e. “some_all” scale only includes “some”, “all”)
m2: Entailment + generic None models (i.e. “some_all” scale includes “none”, “some”, “all”)
m3: Full model with empirical alternatives (i.e. “some_all” scale includes “none”, “some”, “most”, all“)
m4: Entailment + empirical alternatives + additional fitted scalar (i.e. “some_all” scale includes “none”, “some”, “mid”, “most”, all“)
a: Normalized literal listener values before running RSA, no alpha tuning
b: No normalization for literal listener values before running RSA, no alpha tuning
c: Normalized literal listener values before running RSA, alpha tuning
d: No normalization for literal listener values before running RSA, alpha tuning
performance.output$cor.e6 = as.numeric(performance.output$cor.e6)
performance.output$cor.e11 = as.numeric(performance.output$cor.e11)
performance.output = performance.output %>%
mutate(avg.corr =
(cor.e6 + cor.e11) / 2)
performance.output = cbind(performance.output, alphas)
# reorder columns
performance.output = performance.output[, c(1, 2, 3, 5, 4, 6)]
grid.table(performance.output)
Across e6 and e11 pragmatic listener judgements we see model fit improve as we add more alternatives: The largest improvement occurs when we first include the empirically derived salient alternatives (correlations jump +0.23). Have a look at the m2 vs m3 correlation for models with pre-RSA normalization below (c models)
# Tuned, normalized models r
barchart.d = performance.output[c(3, 7, 11, 15), ] %>%
gather(study, cor, cor.e6, cor.e11)
barchart.d$cor = as.numeric(barchart.d$cor)
ggplot(barchart.d, aes(x=model, y=cor, fill=study)) +
geom_bar(stat="identity", position="dodge") +
ylim(0, 1) +
ggtitle("Model fit for e6 and e11\npragmatic listener judgments") +
geom_text(aes(x=model, y=as.numeric(cor) + 0.025, label=round(cor, 3), col=(study)))
Here’s a closer look at the improvement in fit between between normalized m2 and m3.
m2.c.plot
m3.c.jointPlot
Importantly, we also see improvements with the addition of ‘fitted’ alternatives in m4 see the plots below - especially in matching weaker scalar distriubtions (i.e. ‘some’ in ‘some_all’).
m4.c.jointPlot
Non-normalized models seem to be more sensitive to alpha tuning as the number of alternatives increases (see m4.d and m3.d with alpha = 8). I’m not sure if there is a theoretical consideration here that RSA may want to address? What does it mean to normalize literal listener values prior to computing the posterior? One repercussion is that during normalization we’ll see larger impact from salient alternatives…
I was trying to estimate what seemed liked ‘sensible’ alternatives and decided to try and ‘fit’ the distributions for alternatives using a pseudo gradient descent algorithm - fitting alternatives
How can we interpret some of the more funky alternatives (i.e. memorable_unforgettable, some_all)? Does this scalar family ‘want’ more than one more alternative? That is, maybe the model is telling us that only one additional alternative is not enough…? Can we link this intuition back to entropy measures for the scales?
# entropy measures
scales.entropy
## scale Entropy
## 1 good_excellent 4.841411
## 2 liked_loved 3.524465
## 3 memorable_unforgettable 4.964536
## 4 palatable_delicious 5.183348
## 5 some_all 3.743334
m1.a.plot
m1.b.plot
m1.c.plot
m1.d.plot
m2.a.plot
m2.b.plot
m2.c.plot
m2.d.plot
m3.a.plot
m3.b.plot
m3.c.jointPlot
m3.d.jointPlot
m4.a.plot
m4.b.plot
m4.c.jointPlot
m4.d.jointPlot
# bad.predictions = m3.fit.matched$pred > 0 &
# m3.fit.matched$e6.listener.p == 0 &
# (m3.fit.matched$pred - m3.fit.matched$e6.listener.p > 0.05)